home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / del.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  6.2 KB  |  157 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require (in-vicinity (program-vicinity) "sys"))
  21.  
  22. (define defer-block-deletes #f)
  23.  
  24. ;; fixes:
  25. ;; 1. 1/22 blk-delete should not be called if END-OF-CHAIN
  26. ;; 2.      IND-REM-V&K needed to return B-POS
  27. ;; 3.      CHAIN-KEY-REM also neede to check for being already at root level
  28. ;; 4. 1/23 fixed BLK-DELETE? to set access to #f while calling PREV-BLK-ENT!
  29. ;; 5.      fixed CHAIN-KEY-REM to give error message if key not found in index
  30.  
  31. (define (blk-empty? blk)
  32.   (= (BLK-END blk) (next-field blk (+ 1 BLK-DATA-START))))
  33.  
  34. ;; BLK-DELETE assumes caller has ACCWRITE to blk and will
  35. ;; release if after blk-delete returns
  36.  
  37. ;; sorry, waiting on parent-update is losing since
  38. ;; deletes that  lock the entire path to the root will almost certainly
  39. ;; NEVER succeed!
  40.  
  41. (define (blk-delete ent)
  42.   (define blk (ENT-BLK ent))
  43.   (define win? (not defer-block-deletes))
  44. ;;;  (fprintf diagout "BLK-DELETE called, blk=%d:%ld\\n" (ENT-SEG ent) (ENT-ID ent))
  45.   (cond
  46.    (win?
  47.                     ; 1. get and lock PREV
  48.     (ent-update-access ent ACCWRITE #f)    ; KLUGE!!
  49.     (let ((prent (prev-blk-ent ent (BLK-LEVEL blk))))
  50.       (set! win? (ent-update-access ent #f ACCWRITE)) ;need to back out if #f
  51.       (and win? prent            ; if no PRENT, no prev to unlink
  52.        (set! win? (ent-update-access prent ACCREAD ACCWRITE)))
  53.                     ; TBD: double-check that PRENT is still
  54.                     ;PREV of ENT; if not, retry PREV-BLK
  55.       (set! win? (and win? (= 1 (ENT-REF ent)))) ; dont delete blk w/pending parent-update
  56.       (cond
  57.        (win?                ; 2. lock parent
  58.     (if (not (at-root-level? (ENT-SEG ent) blk)) ; no parents to fix!
  59.         (let ((skey-pos (split-key-pos blk)))
  60.           (and
  61.             skey-pos
  62.            (let* ((top-num (BLK-TOP-ID blk))
  63.               (seg (ENT-SEG ent))
  64.               (level (BLK-LEVEL blk))
  65.               (key-str (make-string 256))
  66.               (k-len (recon-this-key blk skey-pos key-str 0 256)))
  67.                     ; 2: fix parent
  68.          (set! win?
  69.                (parent-delete-update seg top-num level (ENT-ID ent)
  70.                          key-str k-len))))))
  71.                     ; if all goes ok, we can make the mods
  72.     (set! win? (and win? (= 1 (ENT-REF ent))))
  73.     (cond
  74.      (win?                ; 3-4:  unlink block from chain
  75.       (if prent (begin (BLK-SET-NXT-ID! (ENT-BLK prent) (BLK-NXT-ID blk))
  76.                (ENT-SET-DTY! prent #t)
  77.                (ent-write prent)))
  78.       (set! win? (blk-free ent))
  79.       (if (not win?)        ; 5 reclaim block
  80.           (fprintf diagout ">>>>ERROR<<<<delete-blk: could not free %d:%ld\\n"
  81.                (ENT-SEG ent) (ENT-ID ent)))))))
  82.       (if prent (release-ent! prent (ENT-ACC prent))))))
  83.   (cond (win? (set! block-deletes (+ block-deletes 1)))
  84.     (else (set! deferred-deletes (+ 1 deferred-deletes))
  85.           (fprintf diagout "Can't delete block %d\\n" (ENT-ID ent))))
  86.   win?)
  87.  
  88. ;;; return #t if operation was succsessful; #f if not
  89. ;;; Note the deletion of blk OLD-ID by removing its KEY+ID from parent.
  90. ;;; Note this routine does not check if the key has already been
  91. ;;; (perhaps by another process) deleted from the parent.
  92.  
  93. (define (parent-delete-update seg top-id level old-id key-str k-len)
  94.   (define pkt (make-vector PKT-SIZE))
  95.   (define ans -1)
  96.   (define ans-str (make-string 4))    ;this is for index blocks only.
  97. ;;;  (fprintf diagout "PARENT-DEL-UPD called, blk=%d:%ld, level=%d, key=%.*s\\n"
  98. ;;;       seg old-id level k-len key-str)
  99.   (let ((ent (find-ent (get-ent seg top-id #f) (+ 1 level) -1 key-str k-len)))
  100.     (cond ((not ent) #f)
  101.       ((ent-update-access ent ACCREAD ACCWRITE)
  102.        (set! ent (chain-find ent ACCWRITE key-str k-len pkt)))
  103.       (else (release-ent! ent ACCREAD)
  104.         (set! ent #f)))
  105.     (cond (ent (set! ans (chain-rem ent key-str k-len ans-str pkt WCB-SAR))
  106.            (if (>= ans 0)
  107.            (if (not (= old-id (str2long ans-str 0)))
  108.                (fprintf diagout ">>>>ERROR<<<< parent-delete-update: bad value %ld in deleted down pointer %ld told\\n"
  109.                 (str2long ans-str 0) old-id)))
  110.            (release-ent! ent ACCWRITE)))
  111.     (cond ((and ent (>= ans 0)))
  112.       (else
  113.        (fprintf diagout "WARNING: parent-delete-update  blk=%d:%ld, level=%d, key=%.*s\\n"
  114.             seg old-id level k-len key-str)
  115.        #f))))
  116.  
  117. ;; called with ACCREAD on ENT, releases ent before returning
  118. ;;; CHAIN-REM can call BLK-DELETE
  119. ;;;   BLK-DELETE calls BLK-FREE
  120. ;;;     BLK-FREE calls AMNESIA-ENT! which sets the segment number to -1
  121. ;;; CHAIN-REM calls RELEASE-ENT!
  122. ;;;; Chad Gadya!
  123.  
  124. (define (chain-rem ent key-str k-len ans-str pkt wcb)
  125. ;;;  (fprintf diagout "CHAIN-REM called, blk=%d:%ld, key=%.*s\\n"
  126. ;;;       (ENT-SEG ent) (ENT-ID ent) k-len key-str)
  127.   (cond ((eq? (MATCH-TYPE pkt) MATCH)
  128.      (let ((alen SUCCESS))
  129.        (if ans-str (set! alen (get-this-val (ENT-BLK ent) (MATCH-POS pkt) ans-str)))
  130.        (blk-remove-key-and-val (ENT-BLK ent)
  131.                    (MATCH-POS pkt)
  132.                    (SEG-BSIZ (ENT-SEG ent)))
  133.        (ENT-SET-DTY! ent #t)
  134.        (if (and (blk-empty? (ENT-BLK ent))
  135.             (not (END-OF-CHAIN? (ENT-BLK ent))))
  136.            (blk-delete ent)
  137.            (let ()
  138. ;;;         (fprintf diagout "CHAIN-REM: blk=%d nonleaf=%d SAR=%d\\n"
  139. ;;;              (BLK-ID (ENT-BLK ent)) (> (BLK-LEVEL (ENT-BLK ent)) LEAF)
  140. ;;;              (WCB-SAR? wcb))
  141.          (if (or (WCB-SAR? wcb) (> (BLK-LEVEL (ENT-BLK ent)) LEAF))
  142.              (ent-write ent))))
  143.        alen))
  144.     (else
  145. ;;;          (fprintf diagout "CHAIN-REM: key %.*s not found in blk %d\\n"
  146. ;;;               k-len key-str (ENT-ID ent))
  147.      NOTPRES)))
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.